home *** CD-ROM | disk | FTP | other *** search
/ Sound Fx / Sound Fx.iso / Software / UNZIPED / DWSTKW / VB / VB4 / PLAY32 / PLAYSTK.BAS next >
Encoding:
BASIC Source File  |  1996-07-08  |  8.1 KB  |  276 lines
  1. '******************************************************************************
  2. ' File:      playstk.c
  3. ' Version:   1.00
  4. ' Tab stops: every 2 columns
  5. ' Project:   DiamondWare's Sound ToolKit for Windows
  6. ' Copyright: 1996 DiamondWare, Ltd.  All rights reserved.*
  7. ' Written:   95/12/11 by David Alen
  8. ' Purpose:   Contains sample application using the WIN-STK
  9. ' History:   96/03/28 KW & JCL finalized for 1.0
  10. '            96/04/14 JCL finalized for 1.01
  11. '            96/03/13 JCL finalized for 1.1 (no changes)
  12. '            96/03/27 JCL finalized for 1.11 (no changes)
  13. '            96/07/08 JCL finalized for 1.2 (no changes)
  14. '
  15. '*Permission is expressely granted to use this program or any derivitive made
  16. ' from it to registered users of the WIN-STK.
  17. '******************************************************************************
  18.  
  19.  
  20.  
  21. Attribute VB_Name = "PLAYSTK"
  22. Option Explicit
  23.  
  24. Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
  25. Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Any) As Long
  26. Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
  27. Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  28. Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
  29. Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
  30. Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  31. Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
  32.  
  33. Public Const GENERIC_READ = &H80000000
  34. Public Const FILE_SHARE_READ = &H1
  35. Public Const OPEN_EXISTING = 3
  36. Public Const FILE_ATTRIBUTE_NORMAL = &H80
  37. Public Const GMEM_MOVEABLE = &H2
  38. Public Const GMEM_SHARE = &H2000
  39.  
  40. Public Const CD_ACTION_OPEN = 1
  41.  
  42. Public Const dws_NOSUCCESS = 0
  43.  
  44. Type SoundInfo
  45.     FileName As String
  46.     Handle As Long
  47.     soundnum As Integer
  48.     Rate As Integer
  49. End Type
  50.  
  51. Global dws_DR As dws_DETECTRESULTS
  52. Global dws_ID As dws_IDEAL
  53. Global dws_DP As dws_DPlay
  54. Global dws_MP As dws_MPlay
  55.  
  56. Global giNumSounds As Integer
  57. Global gtSI() As SoundInfo
  58. Global gPlay As dws_DPlay
  59.  
  60. Public Sub dwsShowError()
  61.     ' An error has occurred!  Show it!
  62.     Dim iError As Integer
  63.     Dim sError As String
  64.     
  65.     iError = dws_ErrNo()
  66.     
  67.     Select Case iError
  68.         Case dws_NOTINITTED
  69.             sError = "Not Initialized"
  70.         Case dws_ALREADYINITTED
  71.             sError = "Already Initialized"
  72.         Case dws_NOTSUPPORTED
  73.             sError = "Not Supported"
  74.         Case dws_INTERNALERROR
  75.             sError = "Internal Error"
  76.         Case dws_INVALIDPOINTER
  77.             sError = "Invalid Pointer"
  78.         Case dws_RESOURCEINUSE
  79.             sError = "Resource In Use"
  80.         Case dws_MEMORYALLOCFAILED
  81.             sError = "Memory Alloc Failed"
  82.         Case dws_SETEVENTFAILED
  83.             sError = "Set Event Failed"
  84.         Case dws_BUSY
  85.             sError = "Busy"
  86.         Case dws_Init_BUFTOOSMALL
  87.             sError = "Buffer Too Small"
  88.         Case dws_D_NOTADWD
  89.             sError = "Not a DWD"
  90.         Case dws_D_NOTSUPPORTEDVER
  91.             sError = "Not Supported Version"
  92.         Case dws_D_BADDPLAY
  93.             sError = "Bad (D) Play"
  94.         Case dws_DPlay_NOSPACEFORSOUND
  95.             sError = "No Space For Sound"
  96.         Case dws_WAV2DWD_NOTAWAVE
  97.             sError = "Not A Wave"
  98.         Case dws_WAV2DWD_UNSUPPORTEDFORMAT
  99.             sError = "Unsupport Format"
  100.         Case dws_M_BADMPLAY
  101.             sError = "Bad (M) Play"
  102.         Case Else
  103.             sError = "<unknown #" + CStr(iError) + ">"
  104.     End Select
  105.     
  106.     MsgBox "Error '" + sError + "' occurred!"
  107. End Sub
  108.  
  109.  
  110. Public Function dwsPlayWave(piIndex As Integer, Optional vCount As Variant) As Boolean
  111.     ' This procedure plays a loaded wave by using the passed
  112.     ' memory handle.
  113.  
  114.     Dim tPlay As dws_DPlay
  115.     Dim iStatus As Integer
  116.  
  117.     LSet tPlay = gPlay
  118.     
  119.     tPlay.snd = gtSI(piIndex).Handle
  120.     
  121.     If Not IsMissing(vCount) Then
  122.         tPlay.count = CInt(vCount)
  123.     Else
  124.         tPlay.count = 1
  125.     End If
  126.     tPlay.flags = dws_dplay_SND Or dws_dplay_COUNT Or dws_dplay_LVOL Or dws_dplay_RVOL Or dws_dplay_PITCH
  127.     
  128.     iStatus = dws_DPlay(tPlay)
  129.         
  130.     gtSI(piIndex).soundnum = tPlay.soundnum
  131.     
  132.     If iStatus = 0 Then
  133.         dwsShowError
  134.         Exit Function
  135.     End If
  136.     
  137.     ' MIDI?!
  138.     
  139.     '    mPlay.track = (UCHAR*)buffer;
  140.     '    mPlay.count = 1;
  141.     '    status = dws_MPlay(&mPlay);
  142.  
  143.     dwsPlayWave = True
  144. End Function
  145.  
  146. Public Function dwsLoadWave(psFileName As String) As Integer
  147.     ' This procedure loads the passed WAVE file and
  148.     ' prepares it for use with the WinSTK.  It returns the INDEX of gtSI()
  149.     ' that the wave was loaded into.
  150.  
  151.     On Error GoTo LWE
  152.  
  153.     Dim WaveDWD As Long
  154.     Dim hWaveDWD As Long
  155.     Dim WaveTmp As Long
  156.     Dim hWaveTmp As Long
  157.     Dim iStatus As Integer
  158.     Dim lLen As Long
  159.     Dim lTemp As Long
  160.     Dim hFile As Long
  161.     Dim iLoop As Integer
  162.     Dim iIndex As Integer
  163.     
  164.     hFile = CreateFile(psFileName, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0&)
  165.     
  166.     If hFile > 0 Then
  167.         lLen = GetFileSize(hFile, ByVal 0&)
  168.  
  169.         hWaveTmp = GlobalAlloc(GMEM_MOVEABLE Or GMEM_SHARE, lLen)
  170.         WaveTmp = GlobalLock(hWaveTmp)
  171.  
  172.         ReadFile hFile, ByVal WaveTmp, lLen, lTemp, ByVal 0&
  173.         CloseHandle (hFile)
  174.     Else
  175.         Exit Function
  176.     End If
  177.     
  178.     If InStr(UCase(psFileName), ".WAV") Then
  179.     
  180.         '  convert WAV to DWD
  181.         lTemp = lLen
  182.         iStatus = dws_WAV2DWD(ByVal WaveTmp, lTemp, ByVal 0&)
  183.         If iStatus = False Then
  184.             dwsShowError
  185.             Exit Function
  186.         End If
  187.     
  188.         hWaveDWD = GlobalAlloc(GMEM_MOVEABLE, lTemp)
  189.         WaveDWD = GlobalLock(hWaveDWD)
  190.     
  191.         iStatus = dws_WAV2DWD(ByVal WaveTmp, lLen, ByVal WaveDWD)
  192.     
  193.         GlobalUnlock (hWaveTmp)
  194.         GlobalFree (hWaveTmp)
  195.     
  196.         If iStatus = False Then
  197.             GlobalUnlock (hWaveDWD)
  198.             GlobalFree (hWaveDWD)
  199.             dwsShowError
  200.             Exit Function
  201.         End If
  202.     Else
  203.         hWaveDWD = hWaveTmp
  204.         WaveDWD = WaveTmp
  205.     End If
  206.     
  207.     iIndex = -1
  208.     
  209.     giNumSounds = giNumSounds + 1
  210.     
  211.     ' Find an empty index if exists
  212.     For iLoop = 0 To UBound(gtSI)
  213.         If gtSI(iLoop).Handle = 0 Then
  214.             ' Use this one!
  215.             iIndex = iLoop
  216.             Exit For
  217.         End If
  218.     Next iLoop
  219.     
  220.     If iIndex = -1 Then
  221.         ReDim Preserve gtSI(UBound(gtSI) + 1) As SoundInfo
  222.         iIndex = UBound(gtSI)
  223.     End If
  224.     
  225.     gtSI(iIndex).FileName = psFileName
  226.     gtSI(iIndex).Handle = WaveDWD
  227.     
  228.     dws_DGetRateFromDWD ByVal gtSI(iIndex).Handle, gtSI(iIndex).Rate
  229.     
  230.     dwsLoadWave = iIndex
  231.     
  232. LWER:
  233.     Exit Function
  234.     
  235. LWE:
  236.     dwsLoadWave = -1
  237.     MsgBox "Error '" + Error + "' occurred in DWSTEST:dwsLoadWave!"
  238.     Resume LWER
  239. End Function
  240.  
  241. Public Function dwsUnloadWave(piIndex As Integer) As Boolean
  242.     ' This procedure removes a loaded WAVE file via
  243.     ' the Wave's Index.
  244.     
  245.     Dim iLoop As Integer
  246.         
  247.     On Error GoTo UWE
  248.  
  249.     If giNumSounds = 0 Or piIndex < 0 Or piIndex > (giNumSounds - 1) Then
  250.         Exit Function
  251.     End If
  252.     
  253.     If gtSI(piIndex).Handle <> 0 Then
  254.         ' Free the memory that's holding the wave
  255.         GlobalUnlock (gtSI(piIndex).Handle)
  256.         GlobalFree (gtSI(piIndex).Handle)
  257.         
  258.         ' Remove the sound Index!
  259.         gtSI(piIndex).Handle = 0
  260.         gtSI(piIndex).FileName = ""
  261.         
  262.         giNumSounds = giNumSounds - 1
  263.         
  264.         dwsUnloadWave = True
  265.     End If
  266.  
  267. UWER:
  268.     Exit Function
  269.     
  270. UWE:
  271.     MsgBox "Error '" + Error + "' occurred in DWSTEST:dwsUnloadLoadWave!"
  272.     Resume UWER
  273. End Function
  274.  
  275.  
  276.